home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol076 / xmodem.for < prev    next >
Encoding:
Text File  |  1987-01-14  |  51.4 KB  |  1,696 lines
  1.  
  2.     program xmodem50
  3. c               MODEM7-type program to send and
  4. c               receive files with checksums or CRC and automatic
  5. c               re-transmission of bad blocks.
  6. c               translated to VAX Fortran V3.0 from TMODEM.C
  7. c               and enhanced according to time-outs and CRC
  8. c               in XMODEM50.ASM
  9. c               J.James Belonis II
  10. c               Physics Hall FM-15
  11. c               University of Washington
  12. c               Seattle, WA 98195
  13. c        (206) 545-8695
  14. c
  15. c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
  16. c   Weinstein
  17. c
  18. c  6/23/84 fixed improper READONLY, open .WRK files carriagecontrol='NONE'
  19. c               made EAT routine continue eating 'til nothing left to eat.
  20. c               increased text conversion capability to 500 character lines.
  21. c        All known bugs are again fixed.
  22. c  6/20/84 Version 5.53 increased filename ttyinlim's to 2 seconds which
  23. c        greatly improved reliability of BATCH mode on heavy loaded VAX
  24. c  5/18/84 Version 5.52 makes OPENs of OLD files READONLY so can work in
  25. c        unowned directories
  26. c  3/21/84 Version 5.51 replaces non-alphanumeric CP/M filename characters
  27. c               by letter "A" when making a VAX filename,
  28. c               commented out bad PRINT.
  29. c  3/17/84 miscellaneous error messages added.
  30. c  3/13/84 reserved space in cancel for eating characters to avoid access viol
  31. C  3/13/84 increased RECVFILE data block timeout to 2 sec
  32. c  2/27/84 Version 5.5 incorporated improvements by Steve Gill
  33. c        GETACK  timeout and garbage loop and NAK, CAN detection
  34. c        RECVFILE receive data block with timeout
  35. c               TTYIN routine removed since replaced everywhere by TTYINLIM
  36. c  1/25/84 properly placed CALL PASSALL in main program so not miss parity bit
  37. c        in sendfn filename checksum
  38. c  1/ 8/84 corrected last known bugs
  39. c  1/ 2/84 Version 5.4 Added batch
  40. c 12/31/83 Version 5.3 Added wildcard filenames(but not yet batch) and
  41. c        streamlined option parsing and allowed CRC TEXT
  42. c        found and fixed blank trim miscalculation
  43. c        again (CONN apparently got old version)
  44. c        XMODEM.LOG and XMODEM.WRK put in SYS$SCRATCH directory
  45. c        (usually user's main) if can't open in current directory
  46. c 12/27/83 Version 5.2 Speeded up SEND by doing only one TTYOUT call per block.
  47. c           no longer hogs CPU at 9600 baud (only 15-20 percent of cpu time)
  48. c           included QIO.DCK so only one file XMODEM.FOR is needed.
  49. c  6/30/83 Modified, restructured, and VAX/VMS text file
  50. c       conversion added by Richard Conn
  51. c  1/17/83      touched up filename display and comments.
  52. c  1/14/83      including timeouts and CTRL-X cancellation
  53. c               and CRC capability
  54. c
  55. c  keeps a log file of error messages ( deletes it if no errors )
  56. c  sets terminal driver to eightbit, passall
  57. c  may need altypeahd if faster than 1200 baud works to 9600 baud at least.
  58. c  needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
  59. c  nor on ACC VAX
  60. c  many debugging statements left in as comments
  61.  
  62. c  declare variables
  63.  
  64.     include  '($rmsdef)'    ! for LIB$FIND_FILE
  65.        INTEGER*2 CHAN,STATUS(4)
  66.        COMMON /QIO/ CHAN,STATUS
  67.  
  68.         character*128 line, filein, file, filec, filed, workf, options
  69.         integer seploc, worklen, context, istat, length, lengthin
  70.     logical openok, sendopt, recvopt, textopt
  71.     logical getfn, sendfn
  72.  
  73.     logical batchopt,firstbatch
  74.     common /batch/batchopt,firstbatch
  75.  
  76.         logical filedel
  77.         common /filest/filedel
  78.  
  79.         integer errorcount
  80.         common /err/errorcount
  81.  
  82.         integer high,low
  83.     byte highbyte,lowbyte
  84.         common /crcval/high,low
  85.     equivalence (high,highbyte)
  86.     equivalence (low,lowbyte)
  87.  
  88.         logical crc
  89.         byte checksumbyte
  90.         integer checksum
  91.         common /checks/checksum,crc
  92.         equivalence (checksum,checksumbyte)
  93.  
  94.         equivalence (ic,c)
  95.  
  96. c  define ascii characters
  97.         parameter NUL=0         !ignore at SOH time
  98.         parameter SOH=1         !start of header for sector
  99.         parameter EOT=4         !end of transfer
  100.         parameter ACK=6         !acknowlege sector
  101.     parameter BEL=7        !bell warning if stupid
  102.         parameter NAK=21        !not acknowlege sector
  103.         parameter CAN=24        !cancel transfer
  104.         parameter CRCCHAR='C'   !CRC indicating character
  105.  
  106. c  timeouts
  107.         parameter respnaklim=10 !seconds to allow for response to NAK
  108.         parameter naklim=10     !seconds to allow to receive first NAK
  109.         parameter eotlim=10     !seconds to wait for EOT acknowlege
  110.  
  111.         parameter errlim=10     !max errors on a sector
  112.  
  113. c  define an exit routine to get control on all exits to turn off
  114. c  passall and for debug cleanup
  115.             external giveup
  116.         call userex( giveup )
  117.  
  118.         print *,' XMODEM Version 5.53 6/23/84 [BATCH capable]'
  119.  
  120. c  assign terminal channel for QIO calls to send raw bytes.
  121.         call sys$assign('TT',chan,,)
  122.  
  123. c  get command line
  124.         call lib$get_foreign(line,'$_Command: ',,)
  125. c  trim blanks
  126.         do i=80,1,-1
  127.                 length=i
  128.                 if(line(i:i).NE.' ') goto 25
  129.         enddo
  130. c  no command on line
  131.   25    continue
  132.  
  133. c  separate options from filename
  134. c    print *,' length=',length
  135.     seploc = index( line(1:length+1),' ' ) ! +1 so find end if one argument
  136. c    print *,' seploc=',seploc
  137.     options=line(1:seploc-1)
  138.     filein=line(seploc+1:length)
  139. c    print *,'options*',options(1:seploc-1),'*'
  140.     lengthin=length-seploc
  141.     if(lengthin.gt.0) then    ! make sure not index infinite length string
  142.         if(  index( filein(1:lengthin), ' ' ) .ne. 0  ) then
  143. c        print *,'filein*',filein(1:lengthin),'*'
  144. c        print *,'index( filein,'' '')',index(filein(1:lengthin),' ')
  145.         print *,' too many arguments'
  146.         goto 150
  147.         endif
  148.     endif
  149.      
  150.         filedel=.false.
  151. c  parse the options
  152.     batchopt=.false.
  153.     firstbatch=.false.
  154.     textopt=.false.
  155.     sendopt=.false.
  156.     recvopt=.false.
  157.     crc=.false.
  158.     i=0
  159.     if( index(options,'B').NE.0 ) then
  160.         batchopt=.true.
  161.         firstbatch=.true.
  162.         i=i+1
  163.     endif
  164.     if( index(options,'T').NE.0 ) then
  165.         textopt=.true.
  166.         i=i+1
  167.     endif
  168.     if( index(options,'S').NE.0 ) then
  169.         sendopt=.true.
  170.         i=i+1
  171.     endif
  172.     if( index(options,'R').NE.0 ) then
  173.         recvopt=.true.
  174.         i=i+1
  175.     endif
  176.     if( index(options,'C').NE.0 ) then
  177.         crc=.true.
  178.         i=i+1
  179.     endif
  180.  
  181. c  check options
  182.     if(i.ne.seploc-1) then
  183.         print *,char(BEL),' unsupported options ignored'
  184.         print *
  185.     endif
  186.     if(sendopt.and.recvopt) then    ! send and receive simultaneously
  187.         print *,' incompatible options SEND and RECEIVE'
  188.         call exit
  189.     endif
  190.     if(  .not.(recvopt.and.batchopt) .and. lengthin.le.0 ) then
  191. c  no options or no filename
  192.         print *,' insufficient arguments'
  193.         goto 150
  194.     endif
  195.     if( lengthin.gt.0 .and. (recvopt.and.batchopt) ) then
  196.         print *,' filename ignored on batch receive',char(BEL)
  197.     endif
  198.  
  199.  
  200.     context=0    ! initial FAB pointer for LIB$FILE_FIND
  201.         call passall(CHAN,.TRUE.)    ! turn on passall so typeahead
  202.                     ! not strip parity on unsolicited chars
  203. c  BATCH option loop comes here
  204. 100    continue    !GOTO at end comes here for next filename
  205.  
  206. c  open separate log file for each transferred file.
  207.     openok=.true.
  208.     workf='XMODEM.WRK'
  209.     worklen=10
  210.     open(8,file='XMODEM.LOG', iostat=istat,
  211.      1                         carriagecontrol='LIST',status='NEW')
  212.     if(istat.ne.0) then
  213.         if(firstbatch) then
  214.         print *,' Can''t open XMODEM.LOG in this directory,'
  215.         print *,' putting it in your main directory.',char(BEL)
  216.             endif
  217.             open(8,file='SYS$SCRATCH:XMODEM.LOG',
  218.      1                         carriagecontrol='LIST',status='NEW')
  219.         openok=.false.
  220.         workf='SYS$SCRATCH:XMODEM.WRK'
  221.         worklen=22      ! number of chars in file name
  222.     endif
  223.  
  224.     if(recvopt) then        ! wildcards done on other computer
  225.         if(.not.batchopt) then
  226.             file=filein
  227.             length=lengthin
  228.         endif
  229.     else    ! sending, need name(s)
  230.         istat=lib$find_file(filein(1:lengthin),file,context,,)
  231.         if(istat.eq.rms$_nmf) then    ! no more files
  232.             if(batchopt) then !await rcvr's request for filename
  233.                 call waitnlp(80) 
  234.                 call ttyout(ACK,1)    ! tell yes file
  235.             endif
  236.             call ttyout(EOT,1)    ! tell other computer no more
  237.                         ! it receives EOT as first
  238.                         ! char of expected filename
  239. c                print *,' All transfers complete.'
  240.                     write(8,*) ' All transfers complete.'
  241.             close(8,dispose='delete')    ! .LOG file
  242.             call exit
  243.         endif
  244.         if(.not.istat) then
  245.             if(firstbatch.or..not.batchopt) then
  246.                 print *,' LIB$FILE_FIND error'
  247.             endif
  248.             write(8,*) ' LIB$FILE_FIND error'
  249.             call cancel
  250.         endif
  251. c  trim blanks
  252.             do i=128,1,-1
  253.                     length=i
  254.                     if(file(i:i).NE.' ') goto 125
  255.             enddo
  256. c        print *,' couldn''t happen, filename blank'
  257.         write(8,*) ' couldn''t happen, filename blank'
  258.  125        continue
  259.  
  260.     endif
  261.  
  262.     if( sendopt ) then
  263. c  send
  264.         if(batchopt) then
  265. c                                       make a reasonable filename for CP/M
  266.             call cleansfn( file(1:length),filec,leng)
  267.             if(firstbatch) then
  268.               print *,' sending BATCH mode, please run receiver'
  269.             endif
  270.         endif
  271.         if(textopt) then
  272.             if(.not.batchopt) then    ! not batch
  273.                         print *,' Sending Text File: ',file(1:length)
  274.                 print *,' Do not run your receiver yet.'
  275.             endif
  276.                     call vtoc( file(1:length), workf(1:worklen) )
  277. c            print *,' file converted'
  278. c            write(8,*) ' file converted'
  279.                     filedel=.true.  !delete working file when done
  280.             if(batchopt) call sendfn( filec(1:leng) )
  281.                     call sendfile( workf(1:worklen) )
  282.         else    ! not text
  283.             if(.not.batchopt) then
  284.                         print *,' Sending File: ',file(1:length)
  285.             else    ! batchopt
  286.                 call sendfn( filec(1:leng) )
  287.             endif
  288.                     call sendfile( file(1:length) )
  289.         endif        
  290.  
  291.     elseif(recvopt) then
  292. c  receive
  293.         if(batchopt) then
  294.             if(firstbatch) then
  295.                print *, ' Receiving BATCH please run sender'
  296.             endif
  297.             if(.not.getfn(filed,leng)) then
  298.                 call ttyout(EOT,1)
  299. c                print *,' All transfers complete.'
  300.                 write(8,*) ' All transfers complete.'
  301.                 close(8,dispose='delete')    ! log file
  302.                 call exit
  303.             endif
  304.             call cleangfn(filed(1:leng),file,length)
  305.         endif
  306.         if(textopt) then
  307.             if(.not.batchopt) then
  308.                         print *,' Receiving Text File: ',file(1:length)
  309.             endif
  310.                     call recvfile( workf(1:worklen) )
  311.                     filedel=.true.  !delete working file when done
  312.                     call ctov( workf(1:worklen), file(1:length) )
  313.         else    ! not text
  314.             if(.not.batchopt) then
  315.                         print *,' Receiving File: ',file(1:length)
  316.             endif
  317.                     call recvfile( file(1:length) )
  318.         endif
  319.     else
  320. c  else bad command
  321. 150            print *,' Invalid XMODEM Command --'
  322.             print *,' Usage: XMODEM  <SRCTB>  <file> '
  323.             print *,'   S = Send, R = Receive, C = Use CRCs, B = Batch'
  324.             print *,'   T = Convert text files to/from CP/M or VAX/VMS'
  325.     endif
  326.  
  327.     if( batchopt ) then
  328.         firstbatch=.false.    ! don't print informational messages
  329.                     ! from now on
  330.         goto 100        ! get next filename
  331.     endif
  332.  
  333. 200     call exit    ! should probably have a unified exit here ??
  334.  
  335.         end
  336. c------------------------------------------------------
  337.     subroutine cleansfn(file,fileclean,length)
  338.     character*(*) file, fileclean
  339.     integer length
  340. c  clean send file name
  341. c  remove too-specific parts of filename (directory and version)
  342. c  and make understandable by CP/M  11 char no dot, last 3 for type
  343.  
  344.     fileclean=' '
  345.     start=index( file,']' )+1
  346.     end=index( file, ';' )-1
  347.     dot = start-1 + index( file(start:end),'.' )    ! VMS guarantees a dot
  348.     if(start.ne.dot) fileclean(1:)=file(start:dot-1)
  349.     if(dot.ne.end) fileclean(9:)=file(dot+1:end)
  350.     ! note: may overwrite last char of vax 9 char filename before dot
  351.     length=11
  352.     return
  353.  
  354.     end
  355.  
  356. c-------------------------------------
  357.     subroutine sendfn(file)
  358.     character*(*) file
  359. c  sends name for batch checksummed send                
  360.  
  361.     byte c
  362.     integer ic
  363.     equivalence (ic,c)
  364.  
  365.         logical ttyinlim
  366.  
  367.         logical crc
  368.         byte checksumbyte
  369.         integer checksum
  370.         common /checks/checksum,crc
  371.         equivalence (checksum,checksumbyte)
  372.  
  373.     parameter BDNMCH=117    ! badname character 'u'
  374.     parameter OKNMCH=6    ! good name character
  375.     parameter ACK=6        ! acknowlege character
  376.     parameter EOF=26    ! filename terminator
  377.  
  378. 100    continue
  379. c    print *,' Awaiting name NAK'
  380. c    write(8,*) ' Awaiting name NAK'
  381.     call waitnlp(80)    ! await NAK
  382.     call ttyout(ACK,1)    ! tell receiver a filename follows
  383.  
  384.     checksum=0
  385. c    print *,file
  386. c    write(8,*) file
  387.     do i=1,len(file)
  388.         c=ichar( file(i:i) )
  389. c        print *, ' filename character=',c
  390. c        write(8,*) ' filename character=',c
  391.         checksum=checksum+c
  392. c        print *,' checksum=',checksum
  393. c        write(8,*) ' checksum=',checksum
  394.         call ttyout(c,1)
  395. 200        if( .not.ttyinlim(c,1,2) ) then
  396. c            print *,' timeout during name'
  397.             write(8,*) ' timeout during name'
  398.             goto 300
  399.         endif
  400. c        print *,' ACK char received decimal=',c
  401. c        write(8,*) ' ACK char received decimal=',c
  402.         if(c.ne.ACK) goto 200    ! let it time out if bad   eat chars ?
  403.     enddo
  404. c    print *,' EOF end of filename'
  405. c    write(8,*) ' EOF end of filename'
  406.     checksum=checksum+EOF
  407.     call ttyout(EOF,1)
  408.     if( .not.ttyinlim(c,1,2) ) then    ! checksum from receiver (MODEM765.ASM
  409.                     ! did not check for timeout)
  410. c        print *,' timeout awaiting checksum in sendfn'
  411.         write(8,*) ' timeout awaiting checksum in sendfn'
  412.         goto 300
  413.     endif
  414.     if( checksumbyte.ne.c ) then
  415. c  bad filename transmission
  416. c        print *,' checksum,byte,c=',checksum,checksumbyte,c
  417.         write(8,*) ' checksum,byte,c='
  418.         write(8,'(3z10)') checksum,checksumbyte,c
  419. 300        continue
  420. c        print *,' BDNMCH = u'
  421. c        write(8,*) ' BDNMCH = u'
  422.         call ttyout(BDNMCH,1)    ! lower case u (but receiver
  423.                     ! only cares that it was not ACK)
  424. c        print *,' receiver better NAK now to start again'
  425.         goto 100
  426.     endif
  427. c    print *,' filename sent ok'
  428. c    write(8,*) ' filename sent ok'
  429.     call ttyout(OKNMCH,1)    ! ACK
  430.     return
  431.     end
  432. c---------------------------------------------------------
  433.     subroutine waitnlp(sec)
  434.     integer sec
  435. c  Await NAK, Cancel if not here in sec seconds, or if CAN, ignore garbage
  436.  
  437.     integer count
  438.         logical ttyinlim
  439.     byte c
  440.     parameter NAK=21
  441.     parameter CAN=24
  442.  
  443.     count=0
  444. 100    if( .not.ttyinlim(c,1,1) ) then    ! timeout
  445.         count=count+1
  446. c        print *,' waitnlp passed limit'
  447.         write(8,*) ' waitnlp passed limit'
  448.         if(count.ge.sec) call cancel    ! passed limit
  449.         goto 100
  450.     elseif( c.eq.CAN ) then
  451. c        print *,' waitnlp canceled'
  452.         write(8,*)' waitnlp canceled'
  453.         call cancel
  454.     elseif( c.ne.NAK ) then        ! ignore garbage
  455. c        print *,' waitnlp not NAK, got decimal=',c
  456.         write(8,*) ' waitnlp not NAK, got decimal=',c
  457.         goto 100
  458.     endif
  459. c  must have gotten NAK
  460.     return
  461.  
  462.     end
  463. c---------------------------------------
  464.     logical function getfn(file,length)
  465.     character*(*) file
  466.     integer length
  467. c  get the characters of the batch mode filename  (return false if no more)
  468. c  note: must be declared in callers too.
  469.  
  470.         logical ttyinlim, hsnak
  471.  
  472.     integer ic    ! so char(ic) works
  473.     byte c
  474.  
  475.         logical crc
  476.         byte checksumbyte
  477.         integer checksum
  478.         common /checks/checksum,crc
  479.         equivalence (checksum,checksumbyte)
  480.  
  481.     parameter EOT=4        ! end of batch transfer
  482.     parameter ACK=6        ! acknowledge character
  483.     parameter OKNMCH=6    ! OK name character   ACK
  484.     parameter EOF=26    ! end of filename
  485.  
  486.     getfn=.true.
  487.     flen=len(file)
  488. 100    checksum=0
  489.     length=0
  490.     file=' '    ! blank filename
  491. c  handshake to make sure synchronized
  492. 150    if( .not.hsnak() ) goto 150    ! may hang 'til CTRL-X
  493.  
  494. 200    if( .not.ttyinlim(ic,1,2) ) then
  495. c        print *,' Time out receiving filename=',file
  496.         write(8,*) ' Time out receiving filename=',file
  497.         goto 100    ! give up and restart handshaking
  498.     endif
  499.     length=length+1
  500.     file(length:length)=char(ic)
  501. c    print *,' filename char=',ic
  502. c    write(8,*) ' filename char=',ic
  503. c    print *,' filename=',file(1:length)
  504. c    write(8,*) ' filename=',file(1:length)
  505.     checksum=checksum+ic
  506.  
  507.     if(ic.eq.EOT) then    ! no more filenames
  508. c        write(8,*) ' getfn got EOT'
  509.         getfn=.false.
  510.         return
  511.     endif
  512.  
  513.     if(ic.eq.EOF) then
  514.         length=length-1
  515. c        print *,' getfn got EOF'
  516. c        write(8,*) ' getfn got EOF'
  517. c        print *,file(1:length)
  518. c        write(8,*) file(1:length)
  519.         call ttyout(checksumbyte,1)    ! send calculated checksum
  520.         if(.not.ttyinlim(c,1,2) ) then    ! get verification of checksum
  521.                         ! MODEM765 had no timeout check
  522. c            print *,' timeout awaiting checksum ok'
  523.             write(8,*) ' timeout awaiting checksum ok'
  524.             goto 100    ! restart handshake
  525.         endif
  526.         if(c.eq.OKNMCH) return
  527.  
  528. c        print *,' Checksum error, verification c=',c
  529.         write(8,*) ' Checksum error, verification c=',c
  530.         goto 100    ! restart handshaking
  531.     endif
  532.  
  533.     if(length.ge.flen) then
  534. c        print *,' Too many characters in filename'
  535.         write(8,*) ' Too many characters in filename'
  536.         goto 100    ! start again at NAK
  537.     endif
  538.  
  539.     call ttyout(ACK,1)
  540.     goto 200    ! get next char
  541.  
  542.     end
  543.  
  544. c--------------------------------------
  545.     logical function hsnak()
  546. c  true if get ACK in response to NAK, c returns null if timeout  ???
  547. c  note: must be declared in callers too.
  548.  
  549.     byte c
  550.     logical ttyinlim
  551.     parameter ACK=6
  552.     parameter CAN=24
  553.     parameter NAK=21
  554.  
  555.     call ttyout(NAK,1)
  556. c  checking for CAN is the only way to get out of the loop that
  557. c  calls hsnak
  558.     if( .not.ttyinlim(c,1,2) ) then    ! timeout don't care what c is
  559.         write(8,*) ' hsnak timeout'
  560.         hsnak=.false.
  561.     elseif(c.eq.ACK) then
  562.         hsnak=.true.
  563. c        print *,' hsnak got ACK'
  564. c        write(8,*) ' hsnak got ACK'
  565.     elseif(c.eq.CAN) then
  566.         write(8,*) ' hsnak canceled'
  567.         call cancel
  568. c       else    ! bad character, ignore
  569.     endif
  570.     return
  571.  
  572.     end
  573. c------------------------------------------------------
  574.     subroutine cleangfn(file,fileclean,length)
  575.     character*(*) file, fileclean
  576.     integer length
  577. c  clean get file name
  578. c  and make understandable by VAX 13 char with dot, last 3 for type
  579. c  also replaces non-alphanumeric by "A"
  580.     integer leng
  581.  
  582.     leng=index(file//' ',' ')-1    ! add blank in case none in filename
  583. c    print *,' leng=',leng
  584.     leng=min(leng,8)    ! in case filename and type run together
  585. c    print *,' leng=',leng
  586.     fileclean(1:)=file(1:leng)//'.'//file(9:)
  587.     length=index(fileclean,' ')-1
  588.     do i=1,leng
  589.         if(  (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z')
  590.     1      .or.
  591.     1      (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9')  )
  592.     1        then
  593. c  do nothing
  594.         else    ! not alphanumeric, replace by legal character
  595.             fileclean(i:i)='A'
  596.         endif
  597.     enddo
  598.     do i=leng+2,length
  599.         if(  (fileclean(i:i).ge.'A' .and. fileclean(i:i).le.'Z')
  600.     1      .or.
  601.     1      (fileclean(i:i).ge.'0' .and. fileclean(i:i).le.'9')  )
  602.     1         then
  603. c  do nothing
  604.         else    ! not alphanumeric, replace by legal character
  605.             fileclean(i:i)='A'
  606.         endif
  607.     enddo
  608. c    print *,' length=',length
  609. c    write(8,*) ' cleaned filename VAX form*',fileclean(1:length),'*'
  610.     return
  611.     end
  612. c----------------------------------------------------------------
  613. c  send file
  614.         subroutine sendfile(file)
  615.  
  616. c  declare variables
  617.  
  618.        INTEGER*2 CHAN,STATUS(4)
  619.        COMMON /QIO/ CHAN,STATUS
  620.  
  621.         character*(*) file
  622.  
  623.         byte sectorread(128), sector(130), send(133), c
  624.     equivalence (send(4), sector(1), sectorread(1) )
  625.  
  626.         integer nakwait, stat, ic
  627.         logical ttyinlim
  628.         logical charintime, acked
  629.  
  630.     logical batchopt, firstbatch
  631.     common /batch/batchopt,firstbatch
  632.  
  633.         logical filedel
  634.         common /filest/filedel
  635.  
  636.     integer blocknumber
  637.     byte blockbyte
  638.     equivalence (blocknumber,blockbyte)
  639.  
  640.     integer notblocknumber
  641.     byte notblockbyte
  642.     equivalence (notblocknumber,notblockbyte)
  643.  
  644.         integer errorcount
  645.         common /err/errorcount
  646.  
  647.         integer high,low
  648.     byte highbyte,lowbyte
  649.         common /crcval/high,low
  650.     equivalence (high,highbyte)
  651.     equivalence (low,lowbyte)
  652.  
  653.         logical crc
  654.     byte checksumbyte
  655.         integer checksum
  656.         common /checks/checksum,crc
  657.         equivalence (checksum,checksumbyte)
  658.  
  659.         equivalence (ic,c)
  660.  
  661. c  define ASCII characters
  662.         parameter NUL=0
  663.         parameter SOH=1
  664.         parameter EOT=4
  665.         parameter ACK=6
  666.         parameter NAK=21
  667.         parameter CAN=24
  668.         parameter CRCCHAR='C'
  669. c  timeouts
  670.         parameter respnaklim=10
  671.         parameter naklim=10
  672.         parameter eotlim=10
  673.         parameter errlim=10
  674.  
  675.     if(filedel) then    ! will close(9,disp='delete') so can't readonly
  676.             open(9,name=file,iostat=stat,status='OLD')
  677. c     1             carriagecontrol='NONE',recordtype='FIXED',recl=128)
  678.     else    ! should not delete, so readonly is ok
  679.             open(9,name=file,iostat=stat,status='OLD',readonly)
  680. c     1             carriagecontrol='NONE',recordtype='FIXED',recl=128)
  681.     endif
  682.  
  683.         if(stat) then
  684.         if(.not.batchopt) then
  685.                     print *,'Can''t open ',file,' for send.'
  686.         endif
  687.                 write(8,*) 'Can''t open ',file,' for send.'
  688.                 call cancel
  689.         endif
  690.     if( .not.batchopt ) then
  691.             print *,file,' Open -- Please Run Your Receiver --'
  692.             print *
  693.     endif
  694.         errorcount=0
  695.         blocknumber=1
  696.         nakwait=0
  697.  
  698. c  await first NAK (or 'C') indicating receiver is ready
  699.   200   charintime=ttyinlim(c,1,naklim)         ! return NUL if timeout
  700. c        print *,' first NAK character=',c
  701. c        write(8,*) ' character=',c
  702.         if( .NOT.charintime ) then
  703.         write(8,*) 'initial NAK or C timeout, trying again'
  704.                 nakwait=nakwait+1
  705. c  give the turkey 80 seconds to figure out how to receive a file
  706.                 if(nakwait.ge.80/naklim) call cancel
  707.                 goto 200
  708.         elseif(c.EQ.NAK) then
  709.                 crc=.false.
  710. c        print *,' CHECKSUM mode'
  711.         write(8,*) ' CHECKSUM mode'
  712.         elseif(c.EQ.CRCCHAR) then
  713.                 crc=.true.
  714. c        print *,' CRC mode'
  715.         write(8,*) ' CRC mode'
  716.         elseif(c.EQ.CAN) then
  717.                 call cancel
  718.         else
  719. c  unrecognized character
  720.         write(8,*) 'unrecognized first NAK=',c
  721.                 nakwait=nakwait+1
  722.                 if(nakwait.ge.80/naklim) call cancel
  723.                 goto 200
  724.         endif
  725.  
  726.   300   continue
  727. c  send new sector
  728. c  use equivalence so not need to do inefficient implicit do loop in read
  729.         read(9,1000,end=500) sectorread
  730.  1000   format(128a)
  731.         errorcount=0
  732. c        print *,' sector as read',sector
  733. c        write(8,*) ' sector as read',sector
  734.   400   continue
  735. c  send sector
  736. c        print *,' SOH '
  737. c    write(8,*) ' SOH'
  738.         send(1)=SOH
  739. c  note: equivalence used for fast integer to byte conversion
  740. c        without byte overflow problems
  741.         send(2)=blockbyte
  742.     notblocknumber=not(blocknumber)
  743.         send(3)=notblockbyte
  744. c        print *,' blocknumber=',blocknumber
  745. c        write(8,*) ' blocknumber=',blocknumber
  746.  
  747. c  sector already in sending buffer    done by equivalence
  748.  
  749.         checksum=0
  750.         call clrcrc
  751. c  calc checksum or crc
  752.         if(crc) then
  753. c        write(8,*) ' CRC mode'
  754. c  put all bytes + two finishing zero bytes through updcrc
  755.                 sector(129)=0
  756.                 sector(130)=0
  757.                 call updcrc( sector,130 )
  758.                 send(132)=highbyte
  759.                 send(133)=lowbyte
  760. c        write(8,*) 'highbyte,lowbyte'
  761. c        write(8,'(2z10)') highbyte,lowbyte
  762. c  actually send
  763.         call ttyout(send,133)
  764.         else
  765. c        write(8,*) 'CHECKSUM mode'
  766.                 do i=1,128
  767.                         checksum=checksum+sector(i)
  768.                 enddo
  769. c  this sends low order byte of checksum
  770.                 send(132)=checksumbyte
  771. c                print *,' checksumbyte ',checksumbyte
  772. c                write(8,*) ' checksumbyte ',checksumbyte
  773.         call ttyout(send,132)
  774.         endif
  775.  
  776. c  sector sent, see if receiver acknowleges
  777. c  getack attempts to get ACK
  778. c  if not, repeat sector
  779. c        print *, ' should wait for ACK 10 seconds'
  780. c        write(8,*) ' should wait for ACK 10 seconds'
  781.  
  782.         call getack(acked)
  783. c        print *, ' getack returned=',acked
  784. c        write(8,*) ' getack returned=',acked
  785.         if(.NOT.acked) goto 400
  786.  
  787. c  ACK received, send next sector
  788.         blocknumber=blocknumber+1
  789.         goto 300
  790.  
  791. c  end of file during read.  finish up sending.
  792.   500   continue
  793.         call ttyout(EOT,1)
  794. c  getack attempts to get ACK up to errlim times
  795.         call getack(acked)
  796.         if( .NOT.acked ) goto 500
  797.  
  798. c        print *,' This file Sending complete.'
  799.         write(8,*) ' This file Sending complete.'
  800.         if (filedel) then
  801.                 close(9,dispose='DELETE')
  802.         else
  803.                 close(9)
  804.         endif
  805.         close(8,dispose='DELETE')    ! the .LOG file
  806.         return
  807.         end
  808.  
  809. c----------------------------------------------------------------
  810. c  receive file
  811.         subroutine recvfile(file)
  812.  
  813. c  declare variables
  814.  
  815.        INTEGER*2 CHAN,STATUS(4)
  816.        COMMON /QIO/ CHAN,STATUS
  817.  
  818.         character*(*) file
  819.         byte c, notc, ck
  820.         integer blocknumber, inotc, notnotc, secbytes, stat
  821.         integer testblock, testprev, ic
  822.         logical ttyinlim
  823.         logical charintime, firstsoh
  824.  
  825.     byte sector(130),sectorwrite(128)
  826.     equivalence (sector,sectorwrite)
  827.  
  828.     logical batchopt,firstbatch
  829.     common /batch/batchopt,firstbatch
  830.  
  831.         integer errorcount
  832.         common /err/errorcount
  833.  
  834.         integer high,low
  835.     byte highbyte,lowbyte
  836.         common /crcval/high,low
  837.     equivalence (high,highbyte)
  838.     equivalence (low,lowbyte)
  839.  
  840.         logical crc
  841.         byte checksumbyte
  842.         integer checksum
  843.         common /checks/checksum,crc
  844.         equivalence (checksum,checksumbyte)
  845.  
  846.         equivalence (ic,c)
  847.  
  848. c  define ASCII characters
  849.         parameter NUL=0
  850.         parameter SOH=1
  851.         parameter EOT=4
  852.         parameter ACK=6
  853.         parameter NAK=21
  854.         parameter CAN=24
  855.         parameter CRCCHAR='C'
  856. c  timeouts
  857.         parameter respnaklim=10
  858.         parameter naklim=10
  859.         parameter eotlim=10
  860.         parameter errlim=10
  861.     parameter datalim=2    ! timeout for data block receive
  862.                 ! 1 second wouldn't work on moderately loaded
  863.                 ! VAX, more may be necessary if heavily loaded
  864.  
  865.         open(7,name=file,recl=128,status='NEW',iostat=stat,
  866.      1          carriagecontrol='NONE',recordtype='FIXED')
  867.         if(stat) then
  868.         if(batchopt) then
  869. c                    print *,' Can''t open ',file,' for receive.'    
  870.         else
  871.                     print *,' Can''t open ',file,' for receive.'
  872.         endif
  873.                 write(8,*) ' Can''t open ',file,' for receive.'
  874.         call cancel
  875.         endif
  876.  
  877.     if(.not.batchopt) then
  878.             print *,' Please Send Your File --'
  879.             print *
  880.     endif
  881.  
  882.         if(crc) then
  883.                 secbytes=130
  884.         else            ! checksum mode
  885.                 secbytes=129
  886.         endif
  887.  
  888.         firstsoh=.false.
  889.         errorcount=0
  890.         blocknumber=1
  891.  
  892. c  start the sender by letting ttyinlim time-out in getack routine
  893. c  so it sends a NAK or C
  894.         goto 999
  895.  
  896.   800   continue
  897. c        write(8,*) ' ready for SOH'
  898. c  must allow enough time for other's disk read (xmodem50.asm allows 10sec)
  899.         charintime=ttyinlim(c,1,respnaklim)
  900. c  if no char for a while, try NAK or C again
  901.         if( .NOT.charintime ) then
  902. c                print *,' no response to NAK or C, trying again'
  903.                 write(8,*) ' no response to NAK or C, trying again'
  904.                 goto 999
  905.         endif
  906. c  else received a char so see what it is
  907.         if(c.eq.NUL) goto 800   ! ignore nulls here for compatablity with old
  908.                                 ! versions of modem7
  909.         if(c.EQ.CAN) then
  910. c                print *,' Canceled.  Aborting.'
  911.                 write(8,*) ' Canceled.  Aborting.'
  912.                 call exit
  913.         endif
  914.  
  915. c        print *,' EOT or SOH character=',c
  916. c        write(8,*) ' EOT or SOH character=',c
  917.          if(c.NE.EOT) then
  918.                 if(c.NE.SOH) then
  919. c                        print *,' Not SOH, was decimal ',c
  920.                         write(8,*) ' Not SOH, was decimal ',c
  921.                         goto 999
  922.                 endif
  923.                 firstsoh=.true.
  924.  
  925. c  character was SOH to indicate start of header
  926. c  get block number and complement
  927.                 charintime=ttyinlim(c,1,1)
  928.         if(.not.charintime) then
  929. c            print *,' timeout awaiting block number'
  930.             write(8,*) ' timeout awaiting block number'
  931.             goto 999
  932.         endif
  933. c                print *,' block=',c
  934. c               write(8,*) ' block=',c
  935.  
  936.                 charintime=ttyinlim(notc,1,1)
  937.         if(.not.charintime) then
  938. c            print *,' timeout awaiting block complement'
  939.             write(8,*) ' timeout awaiting block complement'
  940.             goto 999
  941.         endif
  942. c                print *,' block complement=',notc
  943. c                write(8,*) ' block complement=',notc
  944.                 inotc=notc      ! make integer for "not" function
  945.                 notnotc=iand( not(inotc),255 )  ! mask back to byte
  946.  
  947. c  c is low order byte of ic via equivalence statement
  948.                 if(ic.NE.notnotc) then
  949. c                        print *,' block check bad.'
  950.                         write(8,*) ' block check bad.'
  951.                         goto 999
  952.                 endif
  953. c  block number valid but not yet checked against expected
  954.  
  955. c  clear checksum and CRC
  956.                 checksum=0
  957.                 call clrcrc
  958.  
  959. c  receive the sector and checksum bytes in one call (for speed) and to
  960. c  keep from hogging VAX cpu time at high baud rates.
  961. c  secbytes is 129 for checksum, 130 for CRC
  962.         charintime=ttyinlim(sector,secbytes,datalim)
  963. C check for time out
  964.         if(.not.charintime) then
  965. c            print *,' Timeout on data block read'
  966.             write (8,*) ' Timeout on data block read'
  967.             goto 999
  968.         endif
  969.  
  970.                 if(crc) then
  971. c  put data AND CRC bytes through updcrc
  972.                         call updcrc(sector,secbytes)
  973. c  if result non-zero, BAD.
  974.                         if(highbyte.NE.0 .OR.
  975.      1                     lowbyte.NE.0     ) then
  976. c                                print *,' CRC, high,low='
  977.                                 write(8,*) ' CRC, high,low='
  978. c                                print 3000, highbyte,lowbyte
  979.                                 write(8,3000) highbyte,lowbyte
  980.  3000                           format(2z10)
  981.                                 goto 999
  982.                         endif
  983.                 else
  984. c  don't add received checksum byte to checksum
  985.                         do i=1,secbytes-1
  986.                                 checksum=checksum+sector(i)
  987.                         enddo
  988.                         ck=sector(129)
  989. c                        print 2100, ck
  990. c                        write(8,2100) ck
  991.  
  992. c                        print 2100, checksum
  993. c                        write(8,2100) checksum
  994. c                        print 2100, checksumbyte
  995. c                        write(8,2100) checksumbyte
  996. c 2100                   format(' checksum=',z10)
  997.                          if( checksumbyte.NE.ck ) then
  998.                                 write(8,*) ' bad checksum'
  999.                                 goto 999
  1000.                         endif
  1001.                 endif
  1002.  
  1003. c  received OK so we can believe the block number, see which block it was
  1004. c  mask it to be one byte
  1005.                 testblock=iand(blocknumber,255)
  1006.                 testprev=iand( blocknumber-1 ,255)
  1007.                 if( ic.EQ.testprev) then
  1008. c                        print *, ' prev. block again, out of synch'
  1009.                         write(8,*) ' prev. block again, out of synch'
  1010. c  already have this block so don't write it, but ACK anyway to resynchronize
  1011.                         goto 985
  1012.                 elseif( ic.NE.testblock ) then
  1013. c                        print *, ' block number bad.'
  1014.                         write(8,*) ' block number bad.'
  1015.                         goto 999
  1016.                 endif
  1017. c  else was expected block
  1018.  
  1019. c  write before acknowlege so not have to listen while write.
  1020. c  equivalence so not need inefficient implicit do loop
  1021.                 write(7,2000,err=900) sectorwrite
  1022.  2000           format(128a)
  1023.                 goto 975
  1024.  
  1025.   900           write(8,*) ' Can''t write sector. Aborting.'
  1026. c                print *, ' Can''t write sector. Aborting.'
  1027.                 call cancel
  1028.  
  1029.   975           continue
  1030. c  received sector ok, wrote it ok, so acknowlege it to request next.
  1031.                 blocknumber=blocknumber+1
  1032. c  comes here if re-received the previous sector
  1033.   985           continue
  1034.                 errorcount=0
  1035. c                print *, ' ACKing, sector was ok.'
  1036. c                write(8,*) ' ACKing, sector was ok.'
  1037.                 call ttyout(ACK,1)
  1038.                 goto 800
  1039.  
  1040. c  else error so eat garbage in case out of synch and try again
  1041.   999           continue
  1042.                 call eat
  1043. c                print *, ' receive error NAK, block=',blocknumber
  1044.                 write(8,*) ' receive error NAK, block=',blocknumber
  1045.                 if(crc.AND..NOT.firstsoh) then
  1046. c  keep sending 'C'  'til receive first SOH
  1047.                         call ttyout(CRCCHAR,1)
  1048.                 else
  1049.                         call ttyout(NAK,1)
  1050.                 endif
  1051.                 errorcount=errorcount+1
  1052.   998           if(errorcount.GE.errlim) then
  1053. c                        print *,' Unable to receive block. Aborting.'
  1054.                         write(8,*) ' Not receive block. Aborting.'
  1055. c  delete incompletely received file
  1056.                         close(7,dispose='DELETE')
  1057.                         call cancel
  1058.                 endif
  1059. c  retry
  1060.                 goto 800
  1061.         endif
  1062.  
  1063. c  EOT received instead of SOH so file done.
  1064. c  should keep sending ACK 'til no more EOT's ?
  1065.         close(9)
  1066.         close(7)
  1067.         call ttyout(ACK,1)
  1068.         call ttyout(ACK,1)
  1069.         call ttyout(ACK,1)
  1070.  
  1071.         write(8,*) ' Completed.'
  1072. c       print *,   ' Completed.'
  1073. c  transfer ok, so delete the error log file.
  1074.         close(8,dispose='DELETE')
  1075.         return
  1076.         end
  1077.  
  1078. c-------------------------------------------------------------
  1079.         subroutine ctov(input,output)
  1080. c  convert file of XMODEM 128 byte records with embedded <CR><LF>
  1081. c  marking end-of-line and CTRL-Z marking end-of-file
  1082. c  to carriage-control=LIST (normal VAX editable file)
  1083.  
  1084.     parameter linelen=500    ! if longer lines needed, change this
  1085.                 ! and the 'line' declaration below
  1086.  
  1087.         character*80 input,output
  1088.         character*500 line
  1089.         character*1 CR,LF,recchar
  1090.         logical eof, eol
  1091.     integer len
  1092.  
  1093.         logical filedel
  1094.         common /filest/filedel
  1095.  
  1096.     len=0
  1097.     eof=.false.
  1098.     eol=.false.
  1099.         CR=char(13)
  1100.         LF=char(10)
  1101.  
  1102.     if(filedel) then    ! can't readonly since close(9,disp='delete')
  1103.             open(9,file=input,status='OLD')
  1104.     else
  1105.             open(9,file=input,status='OLD',readonly)
  1106.     endif
  1107. c  set maximum output record length (fortran default is 133)
  1108.         open(7,file=output,status='NEW',carriagecontrol='LIST',
  1109.      1                            recl=linelen)
  1110.  
  1111. c  getchar (read new record if no input characters left)
  1112. c  if EOF on input, write line and exit
  1113. c  if CR then
  1114. c    if getchar LF then write line
  1115. c    else put back char and putchar CR into line (error if too long)
  1116. c    endif
  1117. c  else putchar (write error message if line too long)
  1118. c  endif
  1119. c  loop
  1120.  
  1121.   100   call getc(recchar,eof,eol)
  1122.         if(eof) goto 200
  1123.         if(recchar.eq.CR) then
  1124. c           PRINT *,' CR'
  1125.                 call getc(recchar,eof)
  1126.                 if(eof.or.recchar.ne.LF) then
  1127.                         call putback
  1128.  
  1129.                         len=len+1
  1130.                         if(len.ge.linelen+1)
  1131.      1                                 write(8,*)' Out line too long.'
  1132. c               print *,' too long line=',line
  1133.                         line(len:len)=recchar
  1134.                 else
  1135. c  was LF
  1136. c               PRINT *,' LEN=',LEN
  1137. c               print *,' after LF, line=',line(1:len)
  1138.                         write(7,2000) line(1:len)
  1139.                         len=0
  1140.                 endif
  1141.         else
  1142. c  not CR, was "ordinary" character
  1143.                 len=len+1
  1144.                 if(len.ge.linelen+1) then
  1145.                         write(8,*)' Out line too long.'
  1146. c                       PRINT *,' LINE=',LINE(1:len)
  1147.         else
  1148.                     line(len:len)=recchar
  1149.                 endif
  1150.         endif
  1151.  
  1152.         go to 100
  1153.  
  1154. c  flush last line and exit
  1155.   200   continue
  1156.         if(len.gt.0) then
  1157.                 write(7,2000) line(1:len)
  1158.  2000           format(a)
  1159.         len=0
  1160.         endif
  1161.         if (filedel) then
  1162.                 close(9,dispose='DELETE')
  1163.         else
  1164.                 close(9)
  1165.         endif
  1166.         close(7)
  1167.         return
  1168.         end
  1169. c------------------------------------------
  1170.         subroutine getc(c,eof)
  1171.         character*1 c
  1172.         logical eof
  1173. c  get character from a CP/M text file
  1174. c  point to next character in record (read record if necessary)
  1175.         character*1 CTRLZ
  1176.  
  1177.         integer point
  1178.         character*128 record
  1179.         common /reccom/point,record
  1180.         data point/0/
  1181.  
  1182.         logical firsttime
  1183.     common /getccom/firsttime
  1184.         data firsttime/.true./
  1185.  
  1186.         CTRLZ=char(26)
  1187.         point=point+1
  1188.         if( firsttime .or. (point.gt.128) ) then
  1189.                 firsttime=.false.
  1190.   100           read(9,1000,end=200) record
  1191.  1000           format(a)
  1192. c               PRINT *,RECORD
  1193.                 point=1
  1194.         endif
  1195. c  strip parity in case CP/M file had it
  1196.         c=char(iand(ichar(record(point:point)),127))
  1197.         if(c.eq.CTRLZ) goto 200        ! end of CP/M text file
  1198.     return
  1199.  
  1200. c  end of file
  1201.   200   eof=.true.
  1202.     firsttime=.true.    ! ready for next file
  1203.     point=0
  1204.         return
  1205.         end
  1206. c----------------------------------------------
  1207.     subroutine putback
  1208. c  point to previous input character so this character will be getchar result
  1209. c  even works if 1st char of record
  1210.     integer point
  1211.     character*128 record
  1212.     common /reccom/point,record
  1213.  
  1214.     point=point-1
  1215.     return
  1216.     end
  1217. c-------------------------------------------------------------
  1218.         subroutine vtoc(input,output)
  1219. c  convert VAX text file to
  1220. c  file of XMODEM 128 byte records with embedded <CR><LF>
  1221.  
  1222.         character*80 input,output
  1223.         character*1 CR,LF,c
  1224.         logical eof,eol
  1225.  
  1226.     eof=.false.
  1227.     eol=.false. 
  1228.         CR=char(13)
  1229.         LF=char(10)
  1230.  
  1231.         open(9,file=input,status='OLD',READONLY)
  1232.         open(7,file=output,status='NEW',carriagecontrol='NONE',
  1233.      1                               recl=128,recordtype='FIXED')
  1234.  
  1235. c  getchar (read new line if no input characters left)
  1236. c  putchar ( output record if full, close if EOF )
  1237. c  if EOL on input, putchar CR putchar LF (output record if full)
  1238. c  loop
  1239.  
  1240.   100   call getv(c,eof,eol)
  1241.         if(.not.eol) then
  1242.                 call putchar(c,eof)
  1243.                 if(eof) then
  1244.                         return
  1245.                 endif
  1246.         else
  1247. c  end of line
  1248.                 call putchar(CR,eof)
  1249.                 call putchar(LF,eof)
  1250.                 eol=.false.
  1251.                 if(eof) then
  1252.                         return
  1253.                 endif
  1254.         endif
  1255.         go to 100
  1256.  
  1257.         end
  1258. c------------------------------------------
  1259.         subroutine putchar(c,eof)
  1260.         character*1 c
  1261.         logical eof
  1262. c  put character into record (write record if necessary)
  1263. c  if eof, fills out rest of record with CTRL-Z's and exits
  1264.         character*1 CTRLZ
  1265.  
  1266.         integer point
  1267.         character*128 record
  1268.         common /reccom/point,record
  1269.         data point/0/
  1270.  
  1271.         if(eof) goto 200
  1272.         point=point+1
  1273. c  strip parity in case VAX file had it
  1274.         record(point:point)=char(iand(ichar(c),127))
  1275. c       print *,' record(point:point)=',record(point:point)
  1276. c       print *,' point=',point
  1277.    50   if(point.ge.128) then
  1278. c               print *,' record=',record
  1279.   100           write(7,1000) record
  1280.  1000           format(a)
  1281.                 point=0
  1282.         endif
  1283.         return
  1284.  
  1285. c  EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII)
  1286. c  output last record and exit
  1287.   200   continue
  1288. c       print *,' in putchar EOF section'
  1289.         CTRLZ=char(26)
  1290.         do i=point+1,128
  1291.                 record(i:i)=CTRLZ
  1292.         enddo
  1293. c       print *,' record=',record
  1294.         write(7,1000) record
  1295.         close(9)
  1296.         close(7)
  1297.     point=0        ! ready for next file
  1298.         return
  1299.         end
  1300. c-------------------------------------------
  1301.         subroutine getv(inchar,eof,eol)
  1302.         character*1 inchar
  1303.         logical eof,eol
  1304. c  get character from input line (read line if necessary)
  1305. c  returns character and eol=.true. if no more char on line
  1306. c  returns eof if end of file (no character)
  1307.         character*255 line
  1308.         integer len, pos
  1309.         logical firsttime
  1310.         common/lincom/pos,len,line
  1311.         data pos/0/
  1312.  
  1313.         if(pos.eq.0) then
  1314.                 read(9,1000,end=100)len,line(1:len)
  1315.  1000           format(q,a)
  1316. c               print *,' line=',line
  1317.         endif
  1318.         pos=pos+1
  1319.         if(pos.gt.len) then
  1320.                 eol=.true.
  1321.                 pos=0
  1322.                 return
  1323.         endif
  1324. c       print *,' pos=',pos,' line(1:pos)=',line(1:pos)
  1325. c       print *,' line(pos:pos)=',line(pos:pos)
  1326.         inchar=line(pos:pos)
  1327. c       print *,' pos,char',pos,inchar
  1328.         return
  1329. c  EOF
  1330.   100    continue
  1331.     eof=.true.
  1332.     return
  1333.     end
  1334. c-----------------------------------------------------------
  1335.     subroutine clrcrc
  1336. c  clears CRC
  1337.         integer high,low
  1338.     byte highbyte,lowbyte
  1339.         common /crcval/high,low
  1340.     equivalence (high,highbyte)
  1341.     equivalence (low,lowbyte)
  1342.  
  1343.     high=0
  1344.     low=0
  1345.     return
  1346.     end
  1347. c-----------------------------------------------------------
  1348.     subroutine updcrc(bbyte,n)
  1349.     byte bbyte(*)
  1350.     integer n
  1351. c  updates the Cyclic Redundancy Code
  1352. c  uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
  1353. c    and as used by CRCSUBS version 1.20 for 8080 microprocessor
  1354. c    and incorporated into the MODEM7 protocol of the CP/M user's group
  1355. c
  1356. c  during sending:
  1357. c  call clrcrc
  1358. c  call updcrc   for each byte
  1359. c  call fincrc   to finish (or just put 2 extra zero bytes through updcrc)
  1360. c  result to send is low byte of high and low in that order.
  1361. c
  1362. c  during reception:
  1363. c  call clrcrc
  1364. c  call updcrc   all bytes PLUS the two received CRC bytes must be passed
  1365. c       to this routine
  1366. c       then zero in high and low means good checksum
  1367. c
  1368. c  see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
  1369. c
  1370. c  must declare integer to allow shifting
  1371.     integer byte
  1372.     integer bit,bitl,bith
  1373.  
  1374.         integer high,low
  1375.     byte highbyte,lowbyte
  1376.         common /crcval/high,low
  1377.     equivalence (high,highbyte)
  1378.     equivalence (low,lowbyte)
  1379.  
  1380. c    write(8,*) ' inside updcrc'
  1381.     do i=1,n
  1382. c        write(8,*) 'high,low,byte'
  1383. c        write(8,1000) high,low,bbyte
  1384. c1000        format(3z10)
  1385.         byte=bbyte(i)
  1386.  
  1387.         do j=1,8
  1388. c  get high bits of bytes so we don't lose them when shift
  1389. c  positive is left shift
  1390.             bit =ishft( iand(128,byte), -7)
  1391.             bitl=ishft( iand(128,low),  -7)
  1392.             bith=ishft( iand(128,high), -7)
  1393. c            write(8,*) 'bit,bitl,bith'
  1394. c            write(8,1000) bit,bitl,bith
  1395. c  get ready for next iteration
  1396.             newbyte=ishft(byte,1)
  1397.             byte=newbyte        ! introduced dummy variable newbyte
  1398.                         ! to avoid "access violation"
  1399. c            write(8,*) ' byte ready for next iteration'
  1400. c            write(8,1000) byte
  1401. c  shift those bits in
  1402.             low =ishft(low ,1)+bit
  1403.             high=ishft(high,1)+bitl
  1404. c            write(8,*),' high,low after shifting bits in'
  1405. c            write(8,1000) high,low 
  1406.  
  1407.             if(bith.eq.1) then
  1408.                 high=ieor(16,high)
  1409.                 low=ieor(33,low)
  1410. c                write(8,*) ' high,low  after xor'
  1411. c                write(8,1000) high,low
  1412.             endif
  1413.         enddo
  1414.     enddo
  1415.         return
  1416.         end
  1417. c-----------------------------------------------------------
  1418. c    subroutine fincrc
  1419. c  finish CRC calculation for sending    result in high, low
  1420. c  merely runs updcrc with two  zero bytes
  1421. c  NEVER ACTUALLY USED, I JUST PASS TWO EXTRA ZERO BYTES TO UPDCRC WITH SECTOR
  1422. c       integer high,low
  1423. c       byte highbyte,lowbyte
  1424. c       common /crcval/high,low
  1425. c    equivalence (high,highbyte)
  1426. c    equivalence (low,lowbyte)
  1427. c
  1428. c    byte=0
  1429. c    call updcrc(byte)
  1430. c    call updcrc(byte)
  1431. c    return
  1432. c    end
  1433. c-----------------------------------------------------------
  1434.     subroutine eat
  1435. c  eats extra characters 'til pause   used to re-synch after error
  1436. c  in case error was in header, allow at least 1 block of garbage
  1437.     parameter numchar=135    ! allow a few noise bytes beyond 1 block
  1438.     byte buffer(numchar)
  1439.     logical i,ttyinlim
  1440. c
  1441.     parameter maxtime=2
  1442.  
  1443.   100    i=ttyinlim(buffer,numchar,maxtime)
  1444. c    print *,' eating'
  1445. c    write(8,*) 'finished eating'
  1446.     if(istat) goto 100    ! didn't timeout, so char's still coming
  1447. c    print *,' finished eating'
  1448. c    write(8,*) ' finished eating'
  1449. c    write(8,'(16z5)') buffer
  1450.     return
  1451.     end
  1452. c-----------------------------------------------------------
  1453.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  1454.       BYTE LINE(*)
  1455.       INTEGER N,LIMIT
  1456. C              READ CHARACTERS FROM TERMINAL 
  1457. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  1458. C              RECEIVED FOR LIMIT SECONDS
  1459. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  1460. C              MAY HAVE PROBLEM WITH TYPE-AHEAD 
  1461. c    apparent typeahead problem:  in SENDFN, remote can send checksum
  1462. c    too soon after we send EOF, it is seen by typeahead since
  1463. c    this routine has not yet activated, so high bit already stripped
  1464. c       This was solved by using PASSALL routine.
  1465.  
  1466.        INTEGER*2 CHAN,STATUS(4)
  1467.        COMMON /QIO/ CHAN,STATUS
  1468.  
  1469.       INCLUDE '($SSDEF)'    ! defines error status returns
  1470.       INTEGER I
  1471.       INTEGER SYS$QIOW
  1472.       INTEGER*4 terminators(2)
  1473.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  1474.       DATA TERMINATORS/0,0/
  1475. C 
  1476. c    write(8,*) ' inside ttyinlim'
  1477.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  1478.       I = SYS$QIOW(,           !EVENT FLAG
  1479.      -              %VAL(CHAN),         !CHANNEL
  1480.      -              %VAL(%LOC(IO$_TTYREADALL).OR. 
  1481.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  1482.      -              STATUS,,,
  1483.      -              LINE,       !BUFFER
  1484.      -              %VAL(N),   !LENGTH
  1485.      -              %VAL(LIMIT),    !time limit in seconds
  1486.      -              terminators,,)  !no terminators 
  1487. c      print *,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1488. c      write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1489.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  1490.          TTYINLIM=.FALSE.
  1491. c         print *, ' ttyinlim timeout'
  1492.          write(8,*) ' ttyinlim timeout'
  1493.          return
  1494.       ENDIF
  1495.  
  1496.       IF (I) THEN
  1497. c         print *, ' returning from ttyinlim'
  1498. c         write(8,*) ' returning from ttyinlim
  1499.          return
  1500.       endif
  1501. C 
  1502. C              ERROR
  1503.       write(8,*) ' ttyinlim error.'
  1504.       CALL SYS$EXIT( %VAL(I) )
  1505.       END 
  1506. c-----------------------------------------------------------
  1507.       SUBROUTINE TTYOUT(LINE,N) 
  1508.       BYTE LINE(*)
  1509.       INTEGER*2 N
  1510. C  output N characters without interpretation
  1511.  
  1512.        INTEGER*2 CHAN,STATUS(4)
  1513.        COMMON /QIO/ CHAN,STATUS
  1514.  
  1515.       INTEGER I 
  1516.       INTEGER SYS$QIOW
  1517.       EXTERNAL IO$M_NOFORMAT
  1518.       EXTERNAL IO$_WRITEVBLK
  1519. C 
  1520.       IF( N.LE.0 ) THEN
  1521.          WRITE(8,*) ' ttyout called with strange number of char ',N
  1522.          RETURN
  1523.       ENDIF
  1524. C 
  1525. c    print *, ' to be sent by ttyout ', (line(i),i=1,n)
  1526. c    write(8,*) ' to be sent by ttyout ', (line(i),i=1,n)
  1527.       I = SYS$QIOW(,
  1528.      -              %VAL(CHAN), 
  1529.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  1530.      -                   %LOC(IO$M_NOFORMAT)),
  1531.      -              STATUS,,, 
  1532.      -              LINE, 
  1533.      -              %VAL(N),, 
  1534.      -              %VAL(0),, )         !NO CARRIAGE CONTROL 
  1535.       if(I) then
  1536.          return
  1537.       endif
  1538. C 
  1539. C              ERROR
  1540.       write(8,*) ' ttyout error.'
  1541.       CALL SYS$EXIT( %VAL(I) )
  1542.       END
  1543. c--------------------------------------------------
  1544.     subroutine giveup
  1545. c  this exit routine used especially in case exited via QIO problem
  1546.  
  1547.        INTEGER*2 CHAN,STATUS(4)
  1548.        COMMON /QIO/ CHAN,STATUS
  1549.  
  1550. c  note: if want log file message, must re-open since
  1551. c  system already closed all files before this exit handler got control
  1552. c    open(8,file='XMODEM.LOG',access='APPEND')
  1553. c    write(8,*) ' Exit handler.'
  1554.  
  1555. c  turn off passall
  1556.     call passall(CHAN,.FALSE.)
  1557.     return
  1558.     end
  1559. c-----------------------------------------------------
  1560.     SUBROUTINE PASSALL(CHAN,SWITCH)
  1561. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  1562.     IMPLICIT INTEGER (A-Z)
  1563.     INCLUDE '($TTDEF)'
  1564.     INCLUDE '($IODEF)'
  1565.     LOGICAL SWITCH
  1566.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH    !byte reversed LENGTH
  1567.     BYTE CLASS,TYPE,CHARAC,LENGTH
  1568.     INTEGER*2 WIDTH,SPEED
  1569.     EQUIVALENCE(CHARACTER,CHARAC)
  1570.  
  1571. c  sense current terminal driver mode
  1572.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  1573.     1 CLASS,,,,,)
  1574.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  1575.  
  1576.     IF(SWITCH) THEN
  1577. c  turn on 8 bit passall
  1578.         CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  1579.     1                TT$M_EIGHTBIT
  1580.     ELSE
  1581. c  turn off 8 bit passall
  1582.         CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  1583.     1                               .NOT.TT$M_EIGHTBIT
  1584.     ENDIF
  1585.     SPEED=0    !LEAVE SPEED UNCHANGED
  1586.     PAR=0    !LEAVE PARITY UNCHANGED
  1587.  
  1588. c  set terminal mode with desired passall
  1589.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  1590.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  1591.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  1592.     RETURN
  1593.     END
  1594. c---------------------------------------------------
  1595.     SUBROUTINE ERROR(STRING,MSGID)
  1596. c        Types error message
  1597.     IMPLICIT INTEGER(A-Z)
  1598.     CHARACTER*(*) STRING
  1599.     CHARACTER*80 MESSAGE
  1600.  
  1601.     TYPE *,' *** ERROR: ',STRING
  1602.     write(8,*) ' *** ERROR: ',STRING
  1603.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  1604.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  1605.     write(8,*) MESSAGE(1:MSGLEN),CRLF
  1606.     RETURN
  1607.     END
  1608. c-----------------------------------------------------------
  1609.     subroutine cancel
  1610. c  called to cancel send (at least)
  1611.     logical ttyinlim
  1612.     byte c(135)        ! enough space to eat everything
  1613.     parameter CAN=24
  1614.     parameter SPACE=32
  1615.  
  1616. c  eat garbage
  1617.   100    if( ttyinlim(c,135,1) ) goto 100
  1618. c  cancel other end
  1619.     call ttyout(CAN,1)
  1620.  
  1621. c  eat garbage again in case it didn't understand ?
  1622.   200    if( ttyinlim(c,135,1) ) goto 200
  1623. c  clear the CAN from far end's input in case he has already cancelled and so
  1624. c    has not yet read it.
  1625. c      ???? why ? xmodem50.asm does it
  1626.  
  1627.     call ttyout(SPACE,1)
  1628.  
  1629. c    print *,' XMODEM program canceled'
  1630.     write(8,*)' XMODEM program canceled'
  1631.     call exit
  1632.     end
  1633. c------------------------------------------------------
  1634.     subroutine getack(acked)
  1635. c  returns .TRUE. if gets ACK 
  1636.     logical charintime, ttyinlim, acked
  1637.     byte sector(130),c
  1638.  
  1639.     integer errorcount
  1640.     common /err/errorcount
  1641.  
  1642.     parameter ACK=6
  1643.     parameter NAK=21
  1644.     parameter CAN=24
  1645.     parameter errlim=10    ! max number of errors
  1646.     parameter acklim=15    ! seconds to wait for ACK (xmodem.asm uses 10?)
  1647.                 ! but Stern's Northstar takes longer
  1648.                 ! to write 128 sectors
  1649.  
  1650. c    print *,' inside getack'
  1651. c    write(8,*) ' inside getack'
  1652. c  empty typeahead in case garbage
  1653. c    charintime=ttyinlim(sector,130,0)
  1654.  
  1655. c  allow time for disk file write at other end.  Typically 128 sectors.
  1656. c                        Sometimes only 1 track.
  1657. 10    charintime=ttyinlim(c,1,acklim)
  1658. c    print *,' getack got',c
  1659. c    write(8,*) ' getack got',c
  1660.  
  1661.     if( .NOT.charintime ) then
  1662. c        print *, ' timeout in GETACK'        
  1663.         write(8,*) ' timeout in GETACK'        
  1664.         errorcount=errorcount+1
  1665.         if(errorcount.GE.errlim) then
  1666.             write(8,*) ' not acknowleged in 10 tries.'
  1667. c            print *,' Can''t send sector. Aborting.'
  1668.             call cancel
  1669.         endif
  1670.         goto 10        ! try again
  1671.     elseif( c.EQ.ACK ) then
  1672. c  received ACK
  1673.         acked=.TRUE.
  1674.     elseif( c.EQ.NAK ) then
  1675. c        print *,' not ACK, decimal=',c
  1676.         write(8,*) ' not ACK, decimal=',c
  1677.         errorcount=errorcount+1
  1678.         if(errorcount.GE.errlim) then
  1679.             write(8,*) ' not acknowleged in 10 tries.'
  1680. c            print *,' Can''t send sector. Aborting.'
  1681.             call cancel
  1682.         endif
  1683.         acked=.FALSE.
  1684.  
  1685.     elseif(c.EQ.CAN) then 
  1686.         write (8,*) 'Cancel received while waiting for ACK'
  1687.         call cancel
  1688.     else
  1689. c  received garbage, ignore it and try again.
  1690. c  note: this risks seeing ACK inside the burst of garbage, possibly should EAT
  1691. c        print *, ' not ACK, decimal=',c
  1692.         write(8,*) ' not ACK, decimal=',c
  1693.         goto 10
  1694.     endif
  1695.     return
  1696.     end
  1697.